COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	~This is first attempt to write evaluator for extension of lisp
C00006 00003	~SELECTORS
C00007 00004	~THE PREDICATES
C00009 00005	~THE CONSTANTS
C00010 00006	~THE CONSTRUCTORS
C00011 00007	~PRIMITIVE APPLICATIONS--DELTA RULES
C00014 ENDMK
C⊗;
~This is first attempt to write evaluator for extension of lisp
~with form  valed variables. this is really (as usual) an evlauaator
~operating on REPRESENTATION(!!!) of lang, but mapping should be smooth!!
~UNDEFINED SHOULD BE CHECKED...CAN OCCUR FROM (CAR @A) ETC...

(DE SOGM (EXP ENV)
	(COND
	 ((IS_CONST EXP) 	EXP)
	 ((IS_VAR EXP)   	(VALUE EXP ENV))
	 ((IS_COND EXP)  	(EVCOND  (EXPR EXP) ENV))
	 ((IS_FUN_ARGS EXP)	(APPLY_S (FUN EXP) 
					 (LIST_OF_EVALED_ARGS (ARGS EXP) ENV) 
					 ENV))
	 (T UNDEF)
	  ))

(DE APPLY_S(FN ARGS ENV)
	(COND
	 ((IS_UNDEF FN)UNDEF)
	 ((MEMBER UNDEF ARGS) UNDEF)
	 ((IS_CAR FN)  	    (APPLY_CAR ARGS))
	 ((IS_CDR FN)       (APPLY_CDR ARGS))
	 ((IS_CONS FN)      (APPLY_CONS ARGS))
	 ((IS_ATOM FN)      (APPLY_ATOM ARGS))
	 ((IS_EQ FN)        (APPLY_EQ ARGS))
	 ((IS_NAME FN) 	    ((LAMBDA(Y)(COND((EQ Y FN) (MAKE_FORM FN ARGS))
				       	    (T (APPLY_S Y ARGS ENV))))(SOGM FN ENV)))
	 ((IS_LAMBDA FN)    (SOGM (BODY FN) (NEW_ENV (VARS FN) ARGS ENV)))
	 ((IS_LABEL (CAR FN)) (APPLY_S (LABEL_BODY FN) 
					ARGS 
					(NEW_ENV (LIST (LABEL_NAME FN))
						 (LIST (LABEL_BODY FN))
						 ENV)))
	 (T UNDEF)
	  ))

(DE DENOTE (EXP)
	(COND
	 ((IS_NUMBER EXP) EXP)
	 ((IS_TRUTH EXP)  EXP)
	 ((IS_FALSE EXP)  EXP)
	 ((IS_SEXPR EXP)  EXP)
	  ))

(DE VALUE(VAR ENV)
	(COND
	 ((NULL ENV) VAR)
	 ((EQ VAR (NAME(FIRST ENV))) (VAL(FIRST ENV)))
	 (T (VALUE VAR (REST ENV)))
	  ))

(DE EVCOND (EXP ENV)
((LAMBDA(E)
	(COND
	 ((IS_UNDEF E) UNDEF)
	 ((IS_TRUTH E) (SOGM (E EXP) ENV))
	 ((IS_FALSE E) (SOGM (OW EXP) ENV))
	 (T (MAKE_COND  E
			(SOGM (E EXP) ENV)
		   	(SOGM (OW EXP)ENV)))
	  )
 )(SOGM(P EXP) ENV))
	  )

(DE LIST_OF_EVALED_ARGS(ARGS ENV)
	(COND
	 ((NULL ARGS) NIL)
	 (T (CONS (SOGM (FIRST ARGS) ENV) 
	    (LIST_OF_EVALED_ARGS (REST ARGS) ENV)))
	  ))

(DE NEW_ENV (VARS VALS ENV)
	(COND
	 ((NULL VARS) ENV)
	 (T (CONS (MAKE_ENTRY (FIRST VARS)(FIRST VALS))
	          (NEW_ENV (REST VARS)(REST VALS) ENV)))
	  ))
~SELECTORS

(DE FIRST (X)(CAR X))

(DE REST (X)(CDR X))

(DE EXPR(X)(CDR X))

(DE FUN(X)(CAR X))

(DE ARGS(X)(CDR X))

(DE BODY(X)(CADDR X))

(DE VARS(X)(CADR X))

(DE NAME(X)(CAR X))

(DE VAL(X)(CDR X))

(DE P(X)(CAR X))

(DE E(X)(CADR X))

(DE OW(X)(CADDR X))

(DE LABEL_BODY(X)(CADDR X))

(DE LABEL_NAME(X)(CADR X))
~THE PREDICATES
(DE IS_CONST(EXP)
	(COND
	 ((IS_NUMBER EXP) T)
	 ((IS_TRUTH EXP)  T)
	 ((IS_FALSE EXP)  T)
	 ((IS_SEXPR EXP)  T)
	 (T               NIL)
	  ))

(DE IS_VAR(X)(AND(ATOM X)(NOT (IS_CONST X))(NOT(IS_UNDEF X))))

(DE IS_NAME(X)(AND(ATOM X)(NOT (IS_CONST X))(NOT(IS_UNDEF X))))

(DE IS_COND(X)(EQ(CAR X) (QUOTE COND)))

(DE IS_FUN_ARGS (X) (OR(IS_NAME(CAR X))(IS_LAMBDA(CAR X))(IS_LABEL(CAAR X))))

(DE IS_LABEL(X)(EQ X @LABEL))

(DE IS_CAR (X)(EQ X(QUOTE CAR)))

(DE IS_CDR (X)(EQ X(QUOTE CDR)))


(DE IS_CONS (X)(EQ X(QUOTE CONS)))

(DE IS_EQ (X)(EQ X(QUOTE EQ)))

(DE IS_ATOM (X)(EQ X(QUOTE ATOM)))

(DE IS_LAMBDA(X)(EQ (CAR X)(QUOTE LAMBDA)))

(DE IS_NUMBER(X)(NUMBERP X))

(DE IS_TRUTH(X)(EQUAL  X REP_TRUE))

(DE IS_FALSE(X)(EQUAL X REP_FALSE))

(DE IS_UNDEF(X)(EQ X UNDEF))

(DE IS_SEXPR(X)(EQ(CAR X) (QUOTE QUOTE)))


~THE CONSTANTS

(SETQ UNDEF @*U*)

(SETQ FALSE @*FALSE*)

(SETQ TRUE  @*TRUE*)

(SETQ REP_TRUE (LIST @QUOTE TRUE))

(SETQ REP_FALSE (LIST @QUOTE FALSE))
~THE CONSTRUCTORS
(DE MAKE_FORM(X Y)(CONS X Y))

(DE MAKE_UNARY(F X)(LIST F X))

(DE MAKE_CONST(X)(MAKE_UNARY @QUOTE X))

(DE MAKE_BINARY(F X Y)(LIST F X Y))

(DE MAKE_ENTRY(X Y)(CONS X Y))

(DE MAKE_COND(X Y Z)
	(COND
	 ((IS_UNDEF Y) UNDEF)
	 ((IS_UNDEF Z) UNDEF)
	 (T            (LIST @COND X Y Z))
	 ))

~PRIMITIVE APPLICATIONS--DELTA RULES


(DE APPLY_CAR(X)(APPLY_CAR_CDR @CAR X))

(DE APPLY_CDR(X)(APPLY_CAR_CDR @CDR X))

(DE APPLY_CAR_CDR(F Y)
 ((LAMBDA(ARG1)
	(COND
	 ((IS_VAR ARG1)    (MAKE_UNARY  F ARG1))
	 ((IS_UNDEF ARG1)  UNDEF)
	 ((IS_CONST ARG1)  ((LAMBDA(ARG)(COND
					((ATOM ARG) UNDEF)
					(T (MAKE_CONST(F ARG)))))
				(CADR ARG1)))
	 (T                 (MAKE_UNARY F ARG1))
	))
       (CAR Y))
)


(DE APPLY_CONS(X)
((LAMBDA(ARG1 ARG2)
	(COND
	 ((IS_UNDEF ARG1)  UNDEF)
	 ((IS_UNDEF ARG2)  UNDEF)
	 ((IS_VAR ARG1)    (MAKE_BINARY @CONS ARG1 ARG2))
	 ((IS_VAR ARG2)    (MAKE_BINARY @CONS ARG1 ARG2))
	 ((IS_CONST ARG1)  ((LAMBDA(A1 A2)(MAKE_CONST (CONS A1 A2)))
				(CADR ARG1)(CADR ARG2)))
	 (T                (MAKE_BINARY @CONS ARG1 ARG2))
	))(CAR X)(CADR X))
)

(DE APPLY_EQ(X)
((LAMBDA(ARG1 ARG2)
	(COND
	 ((IS_UNDEF ARG1)  UNDEF)
	 ((IS_UNDEF ARG2)  UNDEF)
	 ((AND(IS_CONST ARG1)
	      ((LAMBDA(A1)(NOT(ATOM A1)))
		(CADR ARG1))) 
			   UNDEF)
	 ((AND(IS_CONST ARG2)
	      ((LAMBDA(A1)(NOT(ATOM A1)))
		(CADR ARG2))) 
			   UNDEF)
	 ((IS_VAR ARG1)    (MAKE_BINARY @EQ ARG1 ARG2))
	 ((IS_VAR ARG2)    (MAKE_BINARY @EQ ARG1 ARG2))
	 ((AND(IS_CONST ARG1)
	      (IS_CONST ARG1))
			   (MAKE_CONST
		           ((LAMBDA(A1 A2)(COND
					   ((EQ A1 A2) TRUE)
					   (T          FALSE)))
				(CADR ARG1)(CADR ARG2))))
	 (T                (MAKE_BINARY @EQ ARG1 ARG2))
	))(CAR X)(CADR X))
)

(DE APPLY_ATOM(X)
((LAMBDA(ARG1)
	(COND
	 ((IS_UNDEF ARG1) UNDEF)
	 ((IS_VAR ARG1)   (MAKE_UNARY @ATOM ARG1))
	 ((IS_CONST ARG1) (MAKE_CONST
				((LAMBDA(A1)(COND
					((ATOM A1)TRUE)
					(T        FALSE)))
				(CADR ARG1))))
	 (T               (MAKE_UNARY @ATOM ARG1))
	))(CAR X))
)